perm filename PIC2.F4[P,LCS] blob
sn#084639 filedate 1974-01-26 generic text, type T, neo UTF8
00100 SUBROUTINE PIC2
00200
00300 CC COMMON/DP/IDP(4000)
00400 CC CALL DPYSET(1,IDP,4000)
00500
00600 EQUIVALENCE(LIST,CURV)
00700
00800 DIMENSION CURV(2,3000),HIST(0/63),DIF(3)
00900
01000 COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
01100 1 DEBUG,TE(1),XP(1),YP(1),PARMAX,
01200 1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
01300
01400 COMMON /LISTC/JXX(4000),LIST(6,1000),LIST5(0/1000),NEWEND,LO
01500
01600 COMMON/COMMAC/BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,
01700 1 LSIDE,RSIDE,JCNT,HYSTAB(1)
01800
01900 INTEGER FI,FILEN,EWE,HIST,BITS,
02000 1 XIX,XI,FLINE,RSIDE,
02100 1 NUM2,NUM3,IDD,PL,LIST5,X
02200
02300 REAL LIST,RR,CL,SL,LEAP,LEA6,LEA3,CONST,FRAC,
02400 1 RX,RY,TEXT,TH,W1,W2,B1,B2,V1,V2,
02500 1 LV,LW,LB,D1,D2,CURV,T,X1,X2,A1,A2,C1,C2,MA,LC,
02600 1 D,B,DIF,B0,BB1,C3,C4
02700 DATA JCNT/0/,RTO/6./
02800 DIF(1)=0.0
02900 B0=0.0
03000 BB1=2**BITS-1
03100 CONST=2.41
03200 IF(FLINE.EQ.0.AND.LSIDE.EQ.0.AND.
03300 1 LLINE.EQ.252.AND.RSIDE.EQ.251) CONST=CONST*.6667
03400 68 LEAP=(RR/2.+CONST)*RTO
03500 LEA6=LEAP/6.
03600 LEA3=LEAP/3.
03700 TH=(LEAP**2)*0.075
03800
03900 DO 70 IDD=0,63
04000 70 HIST(IDD)=0
04100 FRAC=64.0/FLOAT(2**BITS)
04200 DO 100 XIX=1,NEWEND
04300 IDD=IFIX(LIST(5,XIX)*FRAC+0.5)
04400 IF(0.GT.IDD) IDD=0
04500 IF(63.LT.IDD) IDD=63
04600 HIST(IDD)=HIST(IDD)+1
04700 100 CONTINUE
04800
04900 DO 110 IDD=1,63
05000 110 HIST(IDD)=HIST(IDD)+HIST(IDD-1)
05100 IF(HIST(63).NE.NEWEND) PAUSE 'ERROR IN PLOU'
05200 NUM2=IFIX(FLOAT(NEWEND)/3.+0.5)
05300 NUM3=IFIX(FLOAT(NEWEND)*2./3.+0.5)
05400 DO 121 IDD=1,63
05500 IF(NUM2.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(2)=FLOAT(
05600 1 IDD)/FRAC
05700 121 IF(NUM3.GE.(HIST(IDD)+HIST(IDD-1))/2) DIF(3)=FLOAT(
05800 1 IDD)/FRAC
05900
06000 DO 123 I=0,1000
06100 123 LIST5(I)=1
06200
06300 125 XI=1
06400 DO 120 XIX=1,NEWEND
06500 D=LIST(5,XIX)
06600 B=LIST(6,XIX)
06700 IF(((B+D.LT.B0+DIF(1)).OR.(B.GT.BB1-DIF(1)
06800 1 )).OR.(D.LT.DIF(1))) GOTO 120
06900 RX=LIST(1,XIX)*RTO
07000 RY=LIST(2,XIX)*RTO
07100 CL=LIST(3,XIX)*LEA6
07200 SL=LIST(4,XIX)*LEA6
07300 CURV(1,XI)=RX-SL
07400 CURV(2,XI)=RY+CL
07500 CURV(3,XI)=RX+SL
07600 CURV(4,XI)=RY-CL
07700 IF(((B+D.LT.B0+DIF(2)).OR.(B.GT.BB1-DIF(2)
07800 1 )).OR.(D.LT.DIF(2))) GOTO 118
07900 LIST5((XI-1)/2)=2
08000 IF(((B+D.LT.B0+DIF(3)).OR.(B.GT.BB1-DIF(3)
08100 1 )).OR.(D.LT.DIF(3))) GOTO 118
08200 LIST5((XI-1)/2)=3
08300 118 XI=XI+2
08400 120 CONTINUE
08500
08600 CC DO 400 PL=1,3
08610 PL=1
08700
08800 CC GOTO(140,130,130),PL
08900 CC130 X=1
09000 CC DO 136 XI=1,EWE-3,2
09100 CC I=(XI-1)/2
09200 CC IF(LIST5(I).LT.PL) GOTO 136
09300 CC C1=CURV(1,XI)
09400 CC C2=CURV(2,XI)
09500 CC C3=CURV(3,XI)
09600 CC C4=CURV(4,XI)
09700 CC CURV(1,X)=C1
09800 CC CURV(2,X)=C2
09900 CC CURV(3,X)=C3
10000 CC CURV(4,X)=C4
10100 CC LIST5((X-1)/2)=LIST5(I)
10200 CC X=X+2
10300 CC136 CONTINUE
10400 CC XI=X
10500
10600 140 EWE=XI+1
10700 FI=1
10800 LA=0
10900 DO 135 XIX=4,EWE,2
11000 LI=XIX-2
11100
11200 IF((2.*CURV(1,LI)-CURV(1,XIX-3)-2.*CURV(1,XIX-1)+
11300 1 CURV(1,XIX))**2+(2.*CURV(2,LI)-CURV(2,XIX-3)-
11400 1 2.*CURV(2,XIX-1)+CURV(2,XIX))**2.LT.TH) GOTO 135
11500
11600 LA=LI
11700 KI=FI+1
11800 CC IF(KI.EQ.LA) GOTO 200
11900 CC IF(PL.GT.1) GOTO 200
12000
12100 CC CURV(1,FI)=CURV(1,FI)*1.5-CURV(1,KI)*0.5
12200 CC CURV(2,FI)=CURV(2,FI)*1.5-CURV(2,KI)*0.5
12300 CC CURV(1,LA)=CURV(1,LA)*1.5-CURV(1,LA-1)*0.5
12400 CC CURV(2,LA)=CURV(2,LA)*1.5-CURV(2,LA-1)*0.5
12500
12600 200 CALL PACK(JCNT,CURV(1,FI),CURV(2,FI),3)
12700 2002 NI=LA-2
12800 JI=FI-1
12900 DO 210 I=JI,NI
13000 KI=I+1
13100 LI=KI+1
13200 MI=LI+1
13300 B1=CURV(1,LI)-CURV(1,KI)
13400 B2=CURV(2,LI)-CURV(2,KI)
13500 IF (I.EQ.JI) GOTO 202
13600 A1=CURV(1,KI)-CURV(1,I)
13700 A2=CURV(2,KI)-CURV(2,I)
13800 GOTO 204
13900 202 A1=B1
14000 A2=B2
14100 204 IF (I.EQ.NI) GOTO 206
14200 C1=CURV(1,MI)-CURV(1,LI)
14300 C2=CURV(2,MI)-CURV(2,LI)
14400 GOTO 208
14500 206 C1=B1
14600 C2=B2
14700 208 MA=A1**2+A2**2
14800 LB=B1**2+B2**2
14900 LC=C1**2+C2**2
15000 V1=A1*LB+B1*MA
15100 V2=A2*LB+B2*MA
15200 W1=B1*LC+C1*LB
15300 W2=B2*LC+C2*LB
15400 LV=SQRT(V1**2+V2**2)
15500 LW=SQRT(W1**2+W2**2)
15600 LB=SQRT(LB)
15700 CC IF (LV.LT.1.E-6.OR.LW.LT.1.E-6) PAUSE 'LV LW'
15800 AA=LB*.5858
15900 AB=AA/LW
16000 AA=AA/LV
16100 V1=V1*AA
16200 V2=V2*AA
16300 W1=W1*AB
16400 W2=W2*AB
16500 D1=B1-V1-W1
16600 D2=B2-V2-W2
16700
16800 DO 220 K=1,8
16900 T=FLOAT(K)/8.
17000 T1=2.-T
17100 T2=3.-2.*T
17200 220 CALL PACK(JCNT,(CURV(1,KI)+(V1*T1+(W1+D1*T2)*T)*T+.5),
17300 1 (CURV(2,KI)+(V2*T1+(W2+D2*T2)*T)*T+.5),2)
17400 210 CONTINUE
17500
17600 135 FI=LA+1
17700 CC IF(PL.EQ.3)RETURN
17800 CC JCNT=JCNT+1
17900 CC400 JXX(JCNT)=-1
18000 C -1 INDICATES 2ND OR 3RD RUN TO BEGIN NOW.
18100 1001 FORMAT(A1)
18101 END
18110
18300 SUBROUTINE PACK(J,X,Y,N)
18400 COMMON /LISTC/JXX(4000),LIST(6,1000),LIST5(0/1000),NEWEND,LO
18500 CC COMMON/DP/IDP(4000)
18600 DATA II/10/
18700 IF(J.GE.4000)RETURN
18800 L=Y
18900 M=X
19310 4 IF(N.EQ.3)GO TO 5
19320 IX=IX+1
19330 IF(IX.LT.II)RETURN
19340 IX=0
19350 C DISPLAYS EVERY IIth LINE
19400 IF((M.EQ.MA.AND.M.EQ.MB).OR.(L.EQ.LA.AND.L.EQ.LB))J=J-1
19500 C TO AVOID SEVERAL POINTS ON STRAIGHT LINE
19600 MB=MA
19700 LB=LA
19800 MA=M
19900 LA=L
20000 5 K=M*100000+L
20100 3 IF(N.EQ.3)K=-K
20200 CC IF(N.EQ.3)GO TO 8
20300 CC IF(II.NE.J)CALL AVECT(M-380,L-200)
20400 CC CALL DPYOUT(1)
20500 CC GO TO 9
20600 CC8 CALL AIVECT(M-380,L-200)
20700 9 J=J+1
20800 JXX(J)=K
20900 CC II=J
21000 CC1 FORMAT(I5,I,I5,I4)
21100 END